home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / macros.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  35KB  |  908 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;; CLX basicly implements a very low overhead remote procedure call
  20. ;;; to the server.  This file contains macros which generate the code
  21. ;;; for both the client AND the server, given a specification of the
  22. ;;; interface. This was done to eliminate errors that may occur because
  23. ;;; the client and server code get/put bytes in different places, and
  24. ;;; it makes it easier to extend the protocol.
  25.  
  26. ;;; This is built on top of BUFFER
  27.  
  28. (in-package 'xlib :use '(lisp))
  29.  
  30. ;;; This variable is used by the required-arg macro just to satisfy compilers.
  31. (defvar *required-arg-dummy*)
  32.  
  33. ;;; An error signalling macro use to specify that keyword arguments are required.
  34. (defmacro required-arg (name)
  35.   `(progn (x-error 'missing-parameter :parameter ',name)
  36.       *required-arg-dummy*))
  37.  
  38. (defmacro lround (index)
  39.   ;; Round up to the next 32 bit boundary
  40.   `(the array-index (logand (index+ ,index 3) -4)))
  41.  
  42. (defmacro wround (index)
  43.   ;; Round up to the next 16 bit boundary
  44.   `(the array-index (logand (index+ ,index 1) -2)))
  45.  
  46. ;;
  47. ;; Data-type accessor functions
  48. ;;
  49. ;;   These functions translate between lisp data-types and the byte,
  50. ;;   half-word or word that gets transmitted across the client/server
  51. ;;   connection
  52.  
  53. (defun index-increment (type)
  54.   ;; Given a type, return its field width in bytes
  55.   (let* ((name (if (consp type) (car type) type))
  56.      (increment (get name 'byte-width :not-found)))
  57.     (when (eq increment :not-found)
  58.       ;; Check for TYPE in a different package
  59.       (when (not (eq (symbol-package name) (find-package 'xlib)))
  60.     (setq name (xintern name))
  61.     (setq increment (get name 'byte-width :not-found)))
  62.       (when (eq increment :not-found)
  63.     (error "~s isn't a known field accessor" name)))
  64.     increment))
  65.  
  66. (eval-when (eval compile load)
  67. (defun getify (name)
  68.   (xintern name '-get))
  69.  
  70. (defun putify (name &optional predicate-p)
  71.   (xintern name '-put (if predicate-p '-predicating "")))
  72.  
  73.                     ;; Use &body so zmacs indents properly
  74. (defmacro define-accessor (name (width) &body get-put-macros)
  75.   ;; The first body form defines the get macro
  76.   ;; The second body form defines the put macro
  77.   ;; The third body form is optional, and defines a put macro that does
  78.   ;; type checking and does a put when ok, else NIL when the type is incorrect.
  79.   ;; If no third body form is present, then these macros assume that
  80.   ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated.
  81.   ;; these predicating puts are used by the OR accessor.
  82.   (declare-arglist name (width) get-macro put-macro &optional predicating-put-macro)
  83.   (when (cdddr get-put-macros)
  84.     (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros)))
  85.   (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name)))
  86.     (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name)))
  87.     (predicating-put (third get-put-macros)))
  88.     `(within-definition (,name define-accessor)
  89.        (setf (get ',name 'byte-width) ,(and width (floor width 8)))
  90.        (defmacro ,(getify name) ,(car get-macro)
  91.      ,@(cdr get-macro))
  92.        (defmacro ,(putify name) ,(car put-macro)
  93.      ,@(cdr put-macro))
  94.        ,@(when (and *type-check?* predicating-put)
  95.        `((setf (get ',name 'predicating-put) t)
  96.          (defmacro ,(putify name t) ,(car predicating-put)
  97.            ,@(cdr predicating-put)))))))
  98. ) ;; End eval-when
  99.  
  100. (define-accessor card32 (32)
  101.   ((index) `(read-card32 ,index))
  102.   ((index thing) `(write-card32 ,index ,thing)))
  103.  
  104. (define-accessor card29 (32)
  105.   ((index) `(read-card29 ,index))
  106.   ((index thing) `(write-card29 ,index ,thing)))
  107.  
  108. (define-accessor card16 (16)
  109.   ((index) `(read-card16 ,index))
  110.   ((index thing) `(write-card16 ,index ,thing)))
  111.  
  112. (define-accessor card8 (8)
  113.   ((index) `(read-card8 ,index))
  114.   ((index thing) `(write-card8 ,index ,thing)))
  115.  
  116. (define-accessor integer (32)
  117.   ((index) `(read-int32 ,index))
  118.   ((index thing) `(write-int32 ,index ,thing)))
  119.  
  120. (define-accessor int16 (16)
  121.   ((index) `(read-int16 ,index))
  122.   ((index thing) `(write-int16 ,index ,thing)))
  123.  
  124. (define-accessor rgb-val (16)
  125.   ;; Used for color's
  126.   ((index) `(card16->rgb-val (read-card16 ,index)))
  127.   ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing))))
  128.  
  129. (define-accessor angle (16)
  130.   ;; Used for drawing arcs
  131.   ((index) `(int16->radians (read-int16 ,index)))
  132.   ((index thing) `(write-int16 ,index (radians->int16 ,thing))))
  133.  
  134. (define-accessor bit (0)
  135.   ;; Like BOOLEAN, but tests bits
  136.   ;; only used by declare-event (:enter-notify :leave-notify)
  137.   ((index bit)
  138.    `(logbitp ,bit (read-card8 ,index)))
  139.   ((index thing bit)
  140.    (if (zerop bit)
  141.        `(write-card8 ,index (if ,thing 1 0))
  142.      `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index))))))
  143.  
  144. (define-accessor boolean (8)
  145.   ((index)
  146.    `(plusp (read-card8 ,index)))
  147.   ((index thing) `(write-card8 ,index (if ,thing 1 0))))
  148.  
  149. (proclaim '(special *buffer*)) ;; Bound with COMPILER-LET inside the buffer macros 
  150.  
  151. (define-accessor drawable (32)
  152.   ((index &optional (buffer *buffer*))
  153.    `(lookup-drawable ,buffer (read-card29 ,index)))
  154.   ((index thing) `(write-card29 ,index (drawable-id ,thing))))
  155.  
  156. (define-accessor window (32)
  157.   ((index &optional (buffer *buffer*))
  158.    `(lookup-window ,buffer (read-card29 ,index)))
  159.   ((index thing) `(write-card29 ,index (window-id ,thing))))
  160.  
  161. (define-accessor pixmap (32)
  162.   ((index &optional (buffer *buffer*))
  163.    `(lookup-pixmap ,buffer (read-card29 ,index)))
  164.   ((index thing) `(write-card29 ,index (pixmap-id ,thing))))
  165.  
  166. (define-accessor gcontext (32)
  167.   ((index &optional (buffer *buffer*))
  168.    `(lookup-gcontext ,buffer (read-card29 ,index)))
  169.   ((index thing) `(write-card29 ,index (gcontext-id ,thing))))
  170.  
  171. (define-accessor cursor (32)
  172.   ((index &optional (buffer *buffer*))
  173.    `(lookup-cursor ,buffer (read-card29 ,index)))
  174.   ((index thing) `(write-card29 ,index (cursor-id ,thing))))
  175.  
  176. (define-accessor colormap (32)
  177.   ((index &optional (buffer *buffer*))
  178.    `(lookup-colormap ,buffer (read-card29 ,index)))
  179.   ((index thing) `(write-card29 ,index (colormap-id ,thing))))
  180.  
  181. (define-accessor font (32)
  182.   ((index &optional (buffer *buffer*))
  183.    `(lookup-font ,buffer (read-card29 ,index)))
  184.   ;; The FONT-ID accessor may make a OpenFont request.  Since we don't support recursive
  185.   ;; with-buffer-request, issue a compile time error, rather than barf at run-time.
  186.   ((index thing)
  187.    (declare (ignore index thing))
  188.    (error "FONT-ID must be called OUTSIDE with-buffer-request.  Use RESOURCE-ID instead.")))
  189.  
  190. ;; Needed to get and put xatom's in events
  191. (define-accessor keyword (32)
  192.   ((index &optional (buffer *buffer*))
  193.    `(lookup-xatom ,buffer (read-card29 ,index)))
  194.   ((index thing &key (buffer *buffer*))
  195.    `(write-card29 ,index (or (atom-id ,thing ,buffer)
  196.                  (error "CLX implementation error in KEYWORD-PUT")))))
  197.  
  198. (define-accessor resource-id (32)
  199.   ((index) `(read-card29 ,index))
  200.   ((index thing) `(write-card29 ,index ,thing)))
  201.  
  202. (define-accessor resource-id-or-nil (32)
  203.   ((index) (let ((id (gensym)))
  204.          `(let ((,id (read-card29 ,index)))
  205.         (and (plusp ,id) ,id))))
  206.   ((index thing) `(write-card29 ,index (or ,thing 0))))
  207.  
  208. (defmacro char-info-get (index)
  209.   `(make-char-info
  210.      :left-bearing (int16-get ,index)
  211.      :right-bearing (int16-get ,(+ index 2))
  212.      :width       (int16-get ,(+ index 4))
  213.      :ascent       (int16-get ,(+ index 6))
  214.      :descent       (int16-get ,(+ index 8))
  215.      :attributes   (card16-get ,(+ index 10))))
  216.  
  217. (define-accessor member8 (8)
  218.   ((index &rest keywords)
  219.    (let ((value (gensym)))
  220.      `(let ((,value (read-card8 ,index)))
  221.     (and (< ,value ,(length keywords))
  222.          (svref ',(apply #'vector keywords) ,value)))))
  223.   ((index thing &rest keywords)
  224.    `(write-card8 ,index (position ,thing
  225.                   #+lispm ',keywords ;; Lispm's prefer lists
  226.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  227.                   :test #'eq)))
  228.   ((index thing &rest keywords)
  229.    (let ((value (gensym)))
  230.      `(let ((,value (position ,thing
  231.                   #+lispm ',keywords
  232.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  233.                   :test #'eq)))
  234.     (and ,value (write-card8 ,index ,value))))))
  235.  
  236. (define-accessor member16 (16)
  237.   ((index &rest keywords)
  238.    (let ((value (gensym)))
  239.      `(let ((,value (read-card16 ,index)))
  240.     (and (< ,value ,(length keywords))
  241.          (svref ',(apply #'vector keywords) ,value)))))
  242.   ((index thing &rest keywords)
  243.    `(write-card16 ,index (position ,thing
  244.                    #+lispm ',keywords ;; Lispm's prefer lists
  245.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  246.                    :test #'eq)))
  247.   ((index thing &rest keywords)
  248.    (let ((value (gensym)))
  249.      `(let ((,value (position ,thing
  250.                   #+lispm ',keywords
  251.                   #-lispm (the simple-vector ',(apply #'vector keywords))
  252.                   :test #'eq)))
  253.     (and ,value (write-card16 ,index ,value))))))
  254.  
  255. (define-accessor member (32)
  256.   ((index &rest keywords)
  257.    (let ((value (gensym)))
  258.      `(let ((,value (read-card29 ,index)))
  259.     (and (< ,value ,(length keywords))
  260.          (svref ',(apply #'vector keywords) ,value)))))
  261.   ((index thing &rest keywords)
  262.    `(write-card29 ,index (position ,thing
  263.                    #+lispm ',keywords ;; Lispm's prefer lists
  264.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  265.                    :test #'eq)))
  266.   ((index thing &rest keywords)
  267.    (if (cdr keywords) ;; IF more than one
  268.        (let ((value (gensym)))
  269.      `(let ((,value (position ,thing
  270.                    #+lispm ',keywords
  271.                    #-lispm (the simple-vector ',(apply #'vector keywords))
  272.                   :test #'eq)))
  273.         (and ,value (write-card29 ,index ,value))))
  274.      `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
  275.  
  276. (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
  277.  
  278. (define-accessor member-vector (32)
  279.   ((index membership-vector)
  280.    `(member-get ,index ,@(coerce (eval membership-vector) 'list)))
  281.   ((index thing membership-vector)
  282.    `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  283.   ((index thing membership-vector)
  284.    `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  285.  
  286. (define-accessor member16-vector (16)
  287.   ((index membership-vector)
  288.    `(member16-get ,index ,@(coerce (eval membership-vector) 'list)))
  289.   ((index thing membership-vector)
  290.    `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  291.   ((index thing membership-vector)
  292.    `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  293.  
  294. (define-accessor member8-vector (8)
  295.   ((index membership-vector)
  296.    `(member8-get ,index ,@(coerce (eval membership-vector) 'list)))
  297.   ((index thing membership-vector)
  298.    `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
  299.   ((index thing membership-vector)
  300.    `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
  301.  
  302. (define-accessor boole-constant (32)
  303.   ;; this isn't member-vector because we need eql instead of eq
  304.   ((index)
  305.    (let ((value (gensym)))
  306.      `(let ((,value (read-card29 ,index)))
  307.     (and (< ,value ,(length *boole-vector*))
  308.          (aref *boole-vector* ,value)))))
  309.   ((index thing)
  310.    `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*))))
  311.   ((index thing)
  312.    (let ((value (gensym)))
  313.      `(let ((,value (position ,thing (the simple-vector *boole-vector*))))
  314.     (and ,value (write-card29 ,index ,value))))))
  315.  
  316. (define-accessor null (32)
  317.   ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
  318.   ((&rest stuff) stuff 0))
  319.  
  320. (define-accessor pad8 (8)
  321.   ((index) index nil)
  322.   ((index value) index value nil))
  323.  
  324. (define-accessor pad16 (16)
  325.   ((index) index nil)
  326.   ((index value) index value nil))
  327.  
  328. (define-accessor bit-vector256 (256)
  329.   ;; used for key-maps
  330.   ;; REAL-INDEX parameter provided so the default index can be over-ridden.
  331.   ;; This is needed for the :keymap-notify event where the keymap overlaps
  332.   ;; the window id.
  333.   ((index &optional (real-index index) data)
  334.    `(read-bitvector256 buffer-bbuf ,real-index ,data))
  335.   ((index map &optional (real-index index) (buffer *buffer*))
  336.    `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
  337.    
  338. (define-accessor string (nil)
  339.   ((length &key buffer)
  340.    `(read-sequence-char ,(or buffer *buffer*) 'string ,length))
  341.   ((index string &key buffer (start 0) end header-length appending)
  342.    (unless buffer (setq buffer *buffer*))
  343.    (unless header-length (setq header-length (lround index)))
  344.    (let* ((real-end (if appending (or end `(length ,string)) (gensym)))
  345.       (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length)
  346.                       ,string ,start ,real-end)))
  347.      (if appending
  348.      form
  349.      `(let ((,real-end ,(or end `(length ,string))))
  350.         (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start)
  351.                            ,header-length)
  352.                        4))
  353.         ,form)))))
  354.  
  355. (define-accessor sequence (nil)
  356.   ((&key length (format 'card32) result-type transform buffer data start)
  357.    `(,(ecase format
  358.     (card8 'read-sequence-card8)
  359.     (int8 'read-sequence-int8)
  360.     (card16 'read-sequence-card16)
  361.     (int16 'read-sequence-int16)
  362.     (card32 'read-sequence-card32)
  363.     (int32 'read-sequence-int32))
  364.      ,(or buffer *buffer*) ,result-type ,length ,transform ,data ,@(when start `(,start))))
  365.   ((index data &key (format 'card32) (start 0) end transform buffer appending)
  366.    (unless buffer (setq buffer *buffer*))
  367.    (let* ((real-end (if appending (or end `(length ,data)) (gensym)))
  368.       (writer (xintern 'write-sequence- format))
  369.       (form `(,writer ,buffer (index+ buffer-boffset ,(lround index))
  370.           ,data ,start ,real-end ,transform)))
  371.      (flet ((maker (size)
  372.           (if appending
  373.           form
  374.           (let ((idx `(index- ,real-end ,start)))
  375.             (unless (= size 1)
  376.               (setq idx `(index-ceiling ,idx ,size)))
  377.             `(let ((,real-end ,(or end `(length ,data))))
  378.                (write-card16 2 (index+ ,idx ,(index-ceiling index 4)))
  379.                ,form)))))
  380.        (ecase format
  381.      ((card8 int8)
  382.       (maker 4))
  383.      ((card16 int16)
  384.       (maker 2))
  385.      ((card32 int32)
  386.       (maker 1)))))))
  387.  
  388. (defmacro client-message-event-get-sequence ()
  389.   '(let* ((format (read-card8 1))
  390.       (sequence (make-array 20 :element-type `(unsigned-byte ,format))))
  391.      (do ((i 12)
  392.       (j 0 (1+ j)))
  393.      ((>= i 32))
  394.        (case format
  395.      (8 (setf (aref sequence j) (read-card8 i))
  396.         (incf i))
  397.      (16 (setf (aref sequence j) (read-card16 i))
  398.          (incf i 2))
  399.      (32 (setf (aref sequence j) (read-card32 i))
  400.          (incf i 4))))
  401.      sequence))
  402.  
  403. (defmacro client-message-event-put-sequence (format sequence)
  404.   `(ecase ,format
  405.      (8  (sequence-put 12 ,sequence
  406.                :format card8
  407.                :end (min (length ,sequence) 20)
  408.                :appending t))
  409.      (16 (sequence-put 12 ,sequence
  410.                :format card16
  411.                :end (min (length ,sequence) 10)
  412.                :appending t))
  413.      (32 (sequence-put 12 ,sequence
  414.                :format card32
  415.                :end (min (length ,sequence) 5)
  416.                :appending t))))
  417.  
  418. ;; Used only in declare-event
  419. (define-accessor client-message-sequence (160)
  420.   ((index format) index format `(client-message-event-get-sequence))
  421.   ((index value format) index `(client-message-event-put-sequence ,format ,value)))
  422.  
  423.  
  424. ;;;
  425. ;;; Compound accessors
  426. ;;;    Accessors that take other accessors as parameters
  427. ;;;
  428. (define-accessor code (0)
  429.   ((index) index '(read-card8 0))
  430.   ((index value) index `(write-card8 0 ,value))
  431.   ((index value) index `(write-card8 0 ,value)))
  432.  
  433. (define-accessor length (0)
  434.   ((index) index '(read-card16 2))
  435.   ((index value) index `(write-card16 2 ,value))
  436.   ((index value) index `(write-card16 2 ,value)))
  437.  
  438. (deftype data () 'card8)
  439.  
  440. (define-accessor data (0)
  441.   ;; Put data in byte 1 of the reqeust
  442.   ((index &optional stuff) index
  443.    (if stuff
  444.        (if (consp stuff)
  445.        `(,(getify (car stuff)) 1 ,@(cdr stuff))
  446.      `(,(getify stuff) 1))
  447.      `(read-card8 1)))
  448.   ((index thing &optional stuff)
  449.    index
  450.    (if stuff
  451.        (if (consp stuff)
  452.        `(macrolet ((write-card32 (index value) index value))
  453.           (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
  454.      `(,(putify stuff) 1 ,thing))
  455.      `(write-card8 1 ,thing)))
  456.   ((index thing &optional stuff)
  457.    index
  458.    (if stuff
  459.        `(and (type? ,thing ',stuff)
  460.          ,(if (consp stuff)
  461.           `(macrolet ((write-card32 (index value) index value))
  462.              (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
  463.         `(,(putify stuff) 1 ,thing)))
  464.      `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
  465.  
  466. ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
  467. ;; when using event-case.  This is pretty gross.
  468.  
  469. (defmacro or-expand (&rest forms #-kcl &environment #-kcl environment)
  470.   `(cond ,@(mapcar #'(lambda (forms)
  471.                (mapcar #'(lambda (form)
  472.                    (macroexpand form #-kcl environment))
  473.                    forms))
  474.            forms)))
  475.  
  476. ;;
  477. ;; the OR type
  478. ;;
  479. (define-accessor or (32)
  480.   ;; Select from among several types (usually NULL and something else)
  481.   ((index &rest type-list #-kcl &environment #-kcl environment)
  482.    (do ((types type-list (cdr types))
  483.     (value (gensym))
  484.     (result))
  485.        ((endp types)
  486.     `(let ((,value (read-card32 ,index)))
  487.        (macrolet ((read-card32 (index) index ',value)
  488.               (read-card29 (index) index ',value))
  489.          ,(macroexpand `(or-expand ,@(nreverse result)) #-kcl environment))))
  490.      (let ((item (car types))
  491.        (args nil))
  492.        (when (consp item)
  493.      (setq args (cdr item)
  494.            item (car item)))
  495.        (if (eq item 'null)  ;; Special case for NULL
  496.        (push `((zerop ,value) nil) result)
  497.      (push
  498.        `((,(getify item) ,index ,@args))
  499.        result)))))
  500.  
  501.   ((index value &rest type-list)
  502.    (do ((types type-list (cdr types))
  503.     (result))
  504.        ((endp types)
  505.     (if (boundp '%mask-bit)
  506.         `(cond ,@(nreverse result)
  507.            ,@(when *type-check?*
  508.                `((t (x-type-error ,value '(or ,@type-list))))))
  509.       `(write-card32 ,index
  510.              (macrolet ((write-card32 (index value) index value))
  511.                (cond ,@(nreverse result)
  512.                  ,@(when *type-check?*
  513.                      `((t (x-type-error ,value '(or ,@type-list))))))))))
  514.      (let* ((type (car types))
  515.         (type-name type)
  516.         (args nil))
  517.        (when (consp type)
  518.      (setq args (cdr type)
  519.            type-name (car type)))
  520.        (push
  521.      `(,@(cond ((get type-name 'predicating-put) nil)
  522.            ((or *type-check?* (cdr types)) `((type? ,value ',type)))
  523.            (t '(t)))
  524.        (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
  525.      result)))))
  526.  
  527. ;;
  528. ;; the MASK type...
  529. ;;     is used to specify a subset of a collection of "optional" arguments.
  530. ;;     A mask type consists of a 32 bit mask word followed by a word for each one-bit
  531. ;;     in the mask.  The MASK type is ALWAYS the LAST item in a request.
  532. ;;
  533. (setf (get 'mask 'byte-width) nil)
  534.  
  535. (defun mask-get (index type-values body-function)
  536.   (declare-funarg function body-function)
  537.   ;; This is a function, because it must return more than one form (called by get-put-items)
  538.   ;; Functions that use this must have a binding for %MASK
  539.   (let* ((bit 0)
  540.      (result
  541.        (mapcar
  542.          #'(lambda (form)
  543.          (if (atom form)
  544.              form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs
  545.            (prog1
  546.              `(when (logbitp ,bit %mask)
  547.             ;; Execute form when bit is set
  548.             ,form)
  549.              (incf bit))))
  550.          (get-put-items
  551.            (+ index 4) type-values nil
  552.            #'(lambda (type index item args)
  553.            index ;; not used
  554.            (funcall body-function type '(* (incf %index) 4) item args))))))
  555.     ;; First form must load %MASK
  556.     `(,@(when (atom (car result))
  557.       (list (pop result)))
  558.       (progn (setq %mask (read-card32 ,index))
  559.          (setq %index ,(ceiling index 4))
  560.          ,(car result))
  561.       ,@(cdr result))))
  562.  
  563. ;; MASK-PUT 
  564.  
  565. (defun mask-put (index type-values body-function)
  566.   (declare-funarg function body-function)
  567.   ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
  568.   ;; A 32 bit value follows for each non-nil value.
  569.   (let ((index-var (gensym)))
  570.     `((let ((%mask 0)
  571.         (,index-var
  572.          #+clx-overlapping-arrays
  573.          (index+ buffer-loffset ,(ceiling index 4)) ;; Index-var is a WORD index
  574.          #-clx-overlapping-arrays
  575.          (index+ buffer-boffset ,(lround index)) ;; Index-var is a BYTE index
  576.          ))
  577.     (macrolet ((write-card32 (index value)
  578.              `(progn
  579.             (setq %mask (logior %mask ,%mask-bit))
  580.             #+clx-overlapping-arrays
  581.             (setf (aref-card32 buffer-lbuf (index-incf ,index)) ,value)
  582.             #-clx-overlapping-arrays
  583.             (setf (aref-card32 buffer-bbuf (index-incf ,index 4)) ,value)))
  584.            (write-card29 (index value)
  585.              `(progn
  586.             (setq %mask (logior %mask ,%mask-bit))
  587.             #+clx-overlapping-arrays
  588.             (setf (aref-card29 buffer-lbuf (index-incf ,index)) ,value)
  589.             #-clx-overlapping-arrays
  590.             (setf (aref-card29 buffer-bbuf (index-incf ,index 4)) ,value)))
  591.            (write-int32 (index value)
  592.              `(progn
  593.             (setq %mask (logior %mask ,%mask-bit))
  594.             #+clx-overlapping-arrays
  595.             (setf (aref-int32 buffer-lbuf (index-incf ,index)) ,value)
  596.             #-clx-overlapping-arrays
  597.             (setf (aref-int32 buffer-bbuf (index-incf ,index 4)) ,value)))
  598.            (null-put (index value) index value nil))
  599.       ,@(let ((%bit 1))
  600.           (get-put-items index-var type-values t 
  601.                  #'(lambda (type index item args)
  602.                  (prog1 
  603.                    `((compiler-let ((%mask-bit ,%bit))
  604.                        ,@(funcall body-function type index item args)))
  605.                    (setq %bit (ash %bit 1)))))))
  606.     (write-card32 ,index %mask)
  607.     (write-card16 2
  608.               #+clx-overlapping-arrays
  609.               (index- (index-incf ,index-var) buffer-loffset)
  610.               #-clx-overlapping-arrays
  611.               (ash (- (index-incf ,index-var 4) buffer-boffset) -2)
  612.               )
  613.     (setf (buffer-boffset ,*buffer*)
  614.           #+clx-overlapping-arrays
  615.           (* ,index-var 4)
  616.           #-clx-overlapping-arrays
  617.           ,index-var
  618.           )))))
  619.  
  620. (define-accessor progn (nil)
  621.   ;; Catch-all for inserting random code
  622.   ;; Note that code using this is then responsible for setting the request length
  623.   ((index statement) index statement)
  624.   ((index statement) index statement))
  625.  
  626.  
  627. ;
  628. ; Wrapper macros, for use around the above
  629. ;
  630. (defvar *inhibit-type-checking* nil) ;; Bind with compiler-let to inhibit type checking
  631.  
  632. (defmacro type-check (value type)
  633.   (when *type-check?*
  634.     `(unless (type? ,value ,type)
  635.        (x-type-error ,value ,type))))
  636.  
  637. (defmacro check-put (index value type &rest args)
  638.   `(,@(if (consp value) ;; Make local binding when value is an expression
  639.       (let ((val (gensym)))
  640.         (prog1 `(let ((,val ,value)))
  641.            (setq value val)))
  642.     '(progn))
  643.     ,(if (or (not *type-check?*) (member type '(or progn pad8 pad16))
  644.          (constantp value) *inhibit-type-checking*)
  645.      `(,(putify type) ,index ,value ,@args)
  646.        ;; Do type checking
  647.        (if (get type 'predicating-put)
  648.        `(or (,(putify type t) ,index ,value ,@args)
  649.         (x-type-error ,value ',(if args `(,type ,@args) type)))
  650.      `(if (type? ,value ',type)
  651.           (,(putify type) ,index ,value ,@args)
  652.         (x-type-error ,value ',(if args `(,type ,@args) type)))))))
  653.  
  654. (defun get-put-items (index type-args putp &optional body-function)
  655.   (declare-funarg (or null function) body-function)
  656.   ;; Given a lists of the form (type item item ... item)
  657.   ;; Calls body-function with four arguments, a function name,
  658.   ;; index, item name, and optional arguments.
  659.   ;; The results are appended together and retured.
  660.   (unless body-function
  661.     (setq body-function
  662.       #'(lambda (type index item args)
  663.           `((check-put ,index ,item ,type ,@args)))))
  664.   (do* ((items type-args (cdr items))
  665.     (type (caar items) (caar items))
  666.     (args nil nil)
  667.     (result nil)
  668.     (sizes nil))
  669.        ((endp items) (values result index sizes))
  670.     (when (consp type)
  671.       (setq args (cdr type)
  672.         type (car type)))
  673.     (cond ((member type '(return buffer)))
  674.       ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values
  675.        (setq result
  676.          (append result (if putp
  677.                     (mask-put index (cdar items) body-function)
  678.                   (mask-get index (cdar items) body-function)))
  679.          index nil))
  680.       (t (do* ((item (cdar items) (cdr item))
  681. ;;           (FUNCTION (IF putp (putify type) (getify type)))
  682.            (increment (index-increment type)))
  683.           ((endp item))
  684.            (when (constantp index)
  685.          (case increment        ;Round up index when needed
  686.            (2 (setq index (wround index)))
  687.            (4 (setq index (lround index)))))
  688.            (setq result
  689.              (append result (funcall body-function type index (car item) args)))
  690.            (when (constantp index)
  691.          ;; Variable length requests have null length increment.
  692.          ;; Variable length requests set the request size 
  693.          ;; & maintain buffer pointers
  694.          (if (null increment) 
  695.              (setq index nil)
  696.            (progn
  697.              (incf index increment)
  698.              (when (and increment (zerop increment)) (setq increment 1))
  699.              (pushnew (* increment 8) sizes)))))))))
  700.  
  701. (defmacro with-buffer-request ((buffer opcode &rest options) &body type-args)
  702.   (let ((*buffer* (gensym))
  703.     (gc-force (second (member :gc-force options)))
  704.     (length (second (member :length options))))
  705.     (multiple-value-bind (code index sizes)
  706.     (get-put-items 4 type-args t)
  707.       `(let ((,*buffer* ,buffer))
  708.      (with-buffer (,*buffer*)
  709.        ,@(when gc-force `((force-gcontext-changes ,gc-force)))
  710.        (writing-buffer-send (,*buffer* :length ,length
  711.                  :sizes (8 16 ,@sizes ,@(cadr (member :sizes options))))
  712.          (setf (buffer-last-request ,*buffer*) buffer-boffset)
  713.          (write-card8 0 ,opcode)       ;; Stick in the opcode
  714.          ,@code
  715.          ,@(when index
  716.          (setq index (lround index))
  717.          `((write-card16 2 ,(ceiling index 4))
  718.            (setf (buffer-boffset ,*buffer*) (+ buffer-boffset ,index))))
  719.          (incf (buffer-request-number ,*buffer*))))
  720.      ,@(unless (member :no-after options)
  721.          `((display-invoke-after-function ,*buffer*)))))))
  722.  
  723. (defmacro with-buffer-reply ((buffer &optional size &rest options) &body body)
  724.   ;; Generate code for returning values
  725.   (declare-arglist (buffer &optional size &key sizes) &body body)
  726.   (let ((buf (gensym)))
  727.     `(let ((,buf ,buffer))
  728.        (wait-for-reply ,buf ,size)
  729.        (reading-buffer-reply (,buf ,@options)
  730.      ,@body))))
  731.  
  732. (defmacro compare-request ((index) &body body)
  733.   `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index)))
  734.           (write-int32 (index item) `(= ,item (read-int32 ,index)))
  735.           (write-card29 (index item) `(= ,item (read-card29 ,index)))
  736.           (write-int29 (index item) `(= ,item (read-int29 ,index)))
  737.           (write-card16 (index item) `(= ,item (read-card16 ,index)))
  738.           (write-int16 (index item) `(= ,item (read-int16 ,index)))
  739.           (write-card8 (index item) `(= ,item (read-card8 ,index)))
  740.           (write-int8 (index item) `(= ,item (read-int8 ,index))))
  741.      (compiler-let ((*inhibit-type-checking* t))
  742.        (and ,@(get-put-items index body t)))))
  743.  
  744. (defmacro put-items ((index) &body body)
  745.   `(progn ,@(get-put-items index body t)))
  746.  
  747. (defmacro decode-type (type value)
  748.   ;; Given an integer and type, return the value
  749.   (let ((args nil))
  750.     (when (consp type)
  751.       (setq args (cdr type)
  752.         type (car type)))
  753.     `(macrolet ((read-card29 (value) value)
  754.         (read-card32 (value) value)
  755.         (read-int32 (value) `(card32->int32 ,value))
  756.         (read-card16 (value) value)
  757.         (read-int16 (value) `(card16->int16 ,value))
  758.         (read-card8 (value) value)
  759.         (read-int8 (value) `(int8->card8 ,value)))
  760.        (,(getify type) ,value ,@args))))
  761.  
  762. (defmacro encode-type (type value)
  763.   ;; Given a value and type, return an integer
  764.   ;; When check-p, do type checking on value
  765.   (let ((args nil))
  766.     (when (consp type)
  767.       (setq args (cdr type)
  768.         type (car type)))
  769.     `(macrolet ((write-card29 (index value) index value)
  770.         (write-card32 (index value) index value)
  771.         (write-int32 (index value) index `(int32->card32 ,value))
  772.         (write-card16 (index value) index value)
  773.         (write-int16 (index value) index `(int16->card16 ,value))
  774.         (write-card8 (index value) index value)
  775.         (write-int8 (index value) index `(int8->card8 ,value)))
  776.        (check-put 0 ,value ,type ,@args))))
  777.  
  778. (defmacro set-decode-type (type accessor value)
  779.   `(setf ,accessor (encode-type ,type ,value)))
  780. (defsetf decode-type set-decode-type)
  781.  
  782.  
  783. ;;;
  784. ;;; Request codes
  785. ;;; 
  786.  
  787. (defconstant *x-createwindow*                  1)
  788. (defconstant *x-changewindowattributes*        2)
  789. (defconstant *x-getwindowattributes*           3)
  790. (defconstant *x-destroywindow*                 4)
  791. (defconstant *x-destroysubwindows*             5)  
  792. (defconstant *x-changesaveset*                 6)
  793. (defconstant *x-reparentwindow*                7)
  794. (defconstant *x-mapwindow*                     8)
  795. (defconstant *x-mapsubwindows*                 9)
  796. (defconstant *x-unmapwindow*                  10)
  797. (defconstant *x-unmapsubwindows*              11) 
  798. (defconstant *x-configurewindow*              12)
  799. (defconstant *x-circulatewindow*              13)
  800. (defconstant *x-getgeometry*                  14)
  801. (defconstant *x-querytree*                    15)
  802. (defconstant *x-internatom*                   16)
  803. (defconstant *x-getatomname*                  17)
  804. (defconstant *x-changeproperty*               18)
  805. (defconstant *x-deleteproperty*               19)
  806. (defconstant *x-getproperty*                  20)
  807. (defconstant *x-listproperties*               21)
  808. (defconstant *x-setselectionowner*            22)  
  809. (defconstant *x-getselectionowner*            23) 
  810. (defconstant *x-convertselection*             24)
  811. (defconstant *x-sendevent*                    25)
  812. (defconstant *x-grabpointer*                  26)
  813. (defconstant *x-ungrabpointer*                27)
  814. (defconstant *x-grabbutton*                   28)
  815. (defconstant *x-ungrabbutton*                 29)
  816. (defconstant *x-changeactivepointergrab*      30)         
  817. (defconstant *x-grabkeyboard*                 31)
  818. (defconstant *x-ungrabkeyboard*               32)
  819. (defconstant *x-grabkey*                      33)
  820. (defconstant *x-ungrabkey*                    34)
  821. (defconstant *x-allowevents*                  35)
  822. (defconstant *x-grabserver*                   36)     
  823. (defconstant *x-ungrabserver*                 37)       
  824. (defconstant *x-querypointer*                 38)       
  825. (defconstant *x-getmotionevents*              39)          
  826. (defconstant *x-translatecoords*              40)               
  827. (defconstant *x-warppointer*                  41)      
  828. (defconstant *x-setinputfocus*                42)        
  829. (defconstant *x-getinputfocus*                43)        
  830. (defconstant *x-querykeymap*                  44)      
  831. (defconstant *x-openfont*                     45)   
  832. (defconstant *x-closefont*                    46)    
  833. (defconstant *x-queryfont*                    47)
  834. (defconstant *x-querytextextents*             48)    
  835. (defconstant *x-listfonts*                    49) 
  836. (defconstant *x-listfontswithinfo*              50)
  837. (defconstant *x-setfontpath*                  51)
  838. (defconstant *x-getfontpath*                  52)
  839. (defconstant *x-createpixmap*                 53)      
  840. (defconstant *x-freepixmap*                   54)   
  841. (defconstant *x-creategc*                     55)
  842. (defconstant *x-changegc*                     56)
  843. (defconstant *x-copygc*                       57)
  844. (defconstant *x-setdashes*                    58)  
  845. (defconstant *x-setcliprectangles*            59)         
  846. (defconstant *x-freegc*                       60)
  847. (defconstant *x-cleartobackground*            61)          
  848. (defconstant *x-copyarea*                     62)
  849. (defconstant *x-copyplane*                    63)
  850. (defconstant *x-polypoint*                    64)
  851. (defconstant *x-polyline*                     65)
  852. (defconstant *x-polysegment*                  66)  
  853. (defconstant *x-polyrectangle*                67)   
  854. (defconstant *x-polyarc*                      68)
  855. (defconstant *x-fillpoly*                     69)
  856. (defconstant *x-polyfillrectangle*            70)        
  857. (defconstant *x-polyfillarc*                  71) 
  858. (defconstant *x-putimage*                     72)
  859. (defconstant *x-getimage*                     73)
  860. (defconstant *x-polytext8*                    74)   
  861. (defconstant *x-polytext16*                   75)   
  862. (defconstant *x-imagetext8*                   76)  
  863. (defconstant *x-imagetext16*                  77)  
  864. (defconstant *x-createcolormap*               78)    
  865. (defconstant *x-freecolormap*                 79) 
  866. (defconstant *x-copycolormapandfree*          80)       
  867. (defconstant *x-installcolormap*              81)  
  868. (defconstant *x-uninstallcolormap*            82)   
  869. (defconstant *x-listinstalledcolormaps*       83)       
  870. (defconstant *x-alloccolor*                   84)
  871. (defconstant *x-allocnamedcolor*              85)    
  872. (defconstant *x-alloccolorcells*              86)   
  873. (defconstant *x-alloccolorplanes*             87)   
  874. (defconstant *x-freecolors*                   88)
  875. (defconstant *x-storecolors*                  89)
  876. (defconstant *x-storenamedcolor*              90)   
  877. (defconstant *x-querycolors*                  91)
  878. (defconstant *x-lookupcolor*                  92)
  879. (defconstant *x-createcursor*                 93)
  880. (defconstant *x-createglyphcursor*            94)    
  881. (defconstant *x-freecursor*                   95)
  882. (defconstant *x-recolorcursor*                96)  
  883. (defconstant *x-querybestsize*                97) 
  884. (defconstant *x-queryextension*               98) 
  885. (defconstant *x-listextensions*               99)
  886. (defconstant *x-setkeyboardmapping*           100)
  887. (defconstant *x-getkeyboardmapping*           101)
  888. (defconstant *x-changekeyboardcontrol*        102)               
  889. (defconstant *x-getkeyboardcontrol*           103)           
  890. (defconstant *x-bell*                         104)
  891. (defconstant *x-changepointercontrol*         105)
  892. (defconstant *x-getpointercontrol*            106)
  893. (defconstant *x-setscreensaver*               107)         
  894. (defconstant *x-getscreensaver*               108)        
  895. (defconstant *x-changehosts*                  109)    
  896. (defconstant *x-listhosts*                    110) 
  897. (defconstant *x-changeaccesscontrol*          111)          
  898. (defconstant *x-changeclosedownmode*          112)
  899. (defconstant *x-killclient*                   113)
  900. (defconstant *x-rotateproperties*          114)
  901. (defconstant *x-forcescreensaver*          115)
  902. (defconstant *x-setpointermapping*            116)
  903. (defconstant *x-getpointermapping*            117)
  904. (defconstant *x-setmodifiermapping*          118)
  905. (defconstant *x-getmodifiermapping*          119)
  906. (defconstant *x-nooperation*                  127)
  907.  
  908.